home *** CD-ROM | disk | FTP | other *** search
/ Experimental BBS Explossion 3 / Experimental BBS Explossion III.iso / pascal / fastdir.zip / FASTDIR.PAS < prev    next >
Pascal/Delphi Source File  |  1993-06-15  |  38KB  |  1,359 lines
  1. { Default Compiler Directives}
  2. {$S-,R-,V-,I-,N-,B-,F-}
  3.  
  4. {$IFNDEF Ver40}
  5.   {Allow overlays}
  6.   {$F+,O-,X+,A-}
  7. {$ENDIF}
  8.  
  9. UNIT FASTDIR;
  10.  
  11. INTERFACE
  12.  
  13. USES Dos;
  14.  
  15. CONST
  16.  
  17.     MaxDirSize = 4096;
  18.  
  19.     Erased  : WORD = $09;
  20.     Moved   : WORD = $0F;
  21.  
  22.     ShowFileType : BOOLEAN = FALSE;
  23.     DoFullSearch : BOOLEAN = TRUE;  { used for FIND_FILEPATH to search all DIRS }
  24.     NoShow       : WORD = Directory + Hidden + VolumeID;
  25.     CurrentLess  : CHAR = 'n';
  26.     SilentDirStr : PATHSTR = '';    { hidden directory ?? }
  27.  
  28. TYPE
  29.  
  30.     FileTypes = (fARC, fPAK, fZIP, fLZH, fARJ, fZOO, fLBR, fCOM, fEXE, fBAT,
  31.                  fSFX, fDIR, fVOL, fOTHER, fERROR);
  32.  
  33.     DirPtr   = ^DirRec;
  34.     DirRec   = RECORD
  35.                  fType  : FILETYPES;
  36.                  Attr   : WORD;
  37.                  Time   : LONGINT;
  38.                  PSize,
  39.                  Size   : LONGINT;
  40.                  Method,
  41.                  Name   : STRING [12];
  42.                  Path   : PathStr;
  43.                  Tag    : BOOLEAN;
  44.                  Next,
  45.                  Prev   : DirPtr;
  46.                END;
  47.  
  48.   LessFunc = FUNCTION (X, Y : DirPtr) : BOOLEAN;
  49.   SortPPtr = ^Sortpage;
  50.   SortPage = ARRAY [0..PRED(MaxDirSize)] OF DirPtr;
  51.  
  52.   DirList  = RECORD
  53.              Root,
  54.              Last,
  55.              Current  : DirPtr;         { Points to Root,Last,Current items }
  56.              Path     : PathStr;        { Dir Path Or Archive Name }
  57.              Mask     : PathStr;        { Command Line or params }
  58.              ArcType  : FILETYPES;      { DIR or Type of Archive }
  59.              Recurse  : BOOLEAN;        { Include SUBS Too }
  60.              Count,
  61.              Tagged   : INTEGER;
  62.              Space,
  63.              TSpace   : LONGINT;
  64.              Less     : LessFunc;       { Sort function }
  65.              END;
  66.  
  67.   ExtractorRec = RECORD
  68.                  Extract  : PathStr;
  69.                  Compress : PathStr;
  70.                  ListChar : Char;
  71.                  END;
  72.  
  73. CONST
  74.  
  75.   Extractors : ARRAY [fARC .. fARJ] OF ExtractorRec = (
  76.  
  77.     (Extract  : 'ARC.EXE e';
  78.      Compress : 'ARC.EXE a';
  79.      ListChar : #32),
  80.  
  81.     (Extract  : 'PAK.EXE e /wa';
  82.      Compress : 'PAK.EXE -a';
  83.      ListChar : #32),
  84.  
  85.     (Extract  : 'PKUNZIP.EXE -o';
  86.      Compress : 'PKZIP.EXE -ex';
  87.      ListChar : '@'),
  88.  
  89.     (Extract  : 'LHARC.EXE -cm';
  90.      Compress : 'LHARC.EXE a';
  91.      ListChar : #32),
  92.  
  93.     (Extract  : 'ARJ.EXE e -y';
  94.      Compress : 'ARJ.EXE a';
  95.      ListChar : '!') );
  96.  
  97. FUNCTION  LessName (X, Y : DirPtr) : BOOLEAN;
  98. FUNCTION  LessExt  (X, Y : DirPtr) : BOOLEAN;
  99. FUNCTION  LessPath (X, Y : DirPtr) : BOOLEAN;
  100. FUNCTION  LessSize (X, Y : DirPtr) : BOOLEAN;
  101. FUNCTION  LessTime (X, Y : DirPtr) : BOOLEAN;
  102. FUNCTION  LessAttr (X, Y : DirPtr) : BOOLEAN;
  103.  
  104. FUNCTION  FileTypePerExtension(fName : PathStr) : FileTypes;
  105. FUNCTION  FileTypeString (FT : FileTypes) : STRING;
  106. FUNCTION  GetArcType (FName : PathStr) : FileTypes;
  107.  
  108. PROCEDURE InitializeDir (VAR Dir : DirList);
  109. PROCEDURE FindFiles (VAR Dir : DirList; SearchPath : PathStr);
  110. PROCEDURE SortFiles (VAR Dir : DirList);
  111. PROCEDURE ReleaseFiles (VAR Dir : DirList);
  112. PROCEDURE SetLess (VAR Dir : DirList; LChar : CHAR);
  113. PROCEDURE GetCommandLine (VAR Mask : PathStr);      { Get MASK from command line     }
  114.  
  115. PROCEDURE UpdateNextPrev (VAR Dir : DirList);
  116. FUNCTION  NthDirItem (VAR Dir : DirList; Item : INTEGER) : DirPtr;
  117.  
  118. FUNCTION  IsDir(fName : PathStr) : BOOLEAN;
  119. FUNCTION  IsArchive(fName : PathStr) : BOOLEAN;
  120.  
  121. PROCEDURE ZipView(VAR Dir : DirList; ZIPFile : String);  { handle ZIP File }
  122. PROCEDURE ArjView(VAR Dir : DirList; ArjFile : String);  { handle ARJ File }
  123. PROCEDURE LzhView(VAR Dir : DirList; LzhFile : String);  { handle LZH File }
  124. PROCEDURE ArcView(VAR Dir : DirList; ArcName : PathStr); { handle ARC,PAK File }
  125.  
  126. PROCEDURE GetFiles(VAR Dir : DirList; Path,Mask : PathStr; Sort : LessFunc);
  127.  
  128. { Interfaced for TEST program }
  129. FUNCTION  PadR (InpStr : STRING; FieldLen : BYTE) : STRING;
  130. FUNCTION  PadL(InpStr : STRING; Len : Byte) : STRING;
  131. FUNCTION  FullPathname (Path, FileMask : PathStr) : PathStr;
  132.  
  133. IMPLEMENTATION
  134.  
  135. { ╔════════════════════════════════════════════════════════════════════════╗ }
  136. { ║                 STRING FUNCTIONS AND PROCEDURES                        ║ }
  137. { ╚════════════════════════════════════════════════════════════════════════╝ }
  138.  
  139.  
  140. Procedure StrUpr(Var S: String); Assembler;
  141. Asm
  142.   push    ds              { Save DS on stack }
  143.   lds     si, S           { Load DS:SI With Pointer to S }
  144.   cld                     { Clear direction flag - String instr. Forward }
  145.   lodsb                   { Load first Byte of S (String length Byte) }
  146.   sub     ah, ah          { Clear high Byte of AX }
  147.   mov     cx, ax          { Move AX in CX }
  148.   jcxz    @Done           { Length = 0, done }
  149.   mov     ax, ds          { Set ES to the value in DS through AX }
  150.   mov     es, ax          { (can't move between two segment Registers) }
  151.   mov     di, si          { DI and SI now point to the first Char. }
  152. @UpCase:
  153.   lodsb                   { Load Character }
  154.   cmp     al, 'a'
  155.   jb      @notLower       { below 'a' -- store as is }
  156.   cmp     al, 'z'
  157.   ja      @notLower       { above 'z' -- store as is }
  158.   sub     al, ('a' - 'A') { convert Character in AL to upper Case }
  159. @notLower:
  160.   stosb                   { Store upCased Character in String }
  161.   loop    @UpCase         { Decrement CX, jump if not zero }
  162. @Done:
  163.   pop     ds              { Restore DS from stack }
  164. end;
  165.  
  166. FUNCTION Uppercase(S : STRING) : STRING;
  167. BEGIN
  168. StrUpr(S);
  169. Uppercase := S;
  170. END;
  171.  
  172. FUNCTION LoCase (InChar : CHAR) : CHAR;
  173. BEGIN
  174.    IF InChar IN ['A'..'Z'] THEN
  175.       LoCase := CHR (ORD (Inchar) + 32)
  176.    ELSE
  177.       LoCase := InChar
  178. END;
  179.  
  180. FUNCTION FixLen (AnyString : STRING; PadChar : CHAR; FldSize : WORD) : STRING;
  181.                                                              assembler;
  182. asm
  183.         PUSH    DS              {Save Data Segment}
  184.         CLD                     {Clear direction flag}
  185.         LDS     SI, AnyString    {DS:SI-->AnyString}
  186.         LES     DI, @Result      {ES:DI-->String to be returned}
  187.         MOV     BX, DI           {Save DI value for later}
  188.         LODSB                   {AL has Length(AnyString)}
  189.         CBW                     {Make AL into word in AX}
  190.         STOSB                   {Put the length into Result & Inc(DI)}
  191.         MOV     CX, AX           {Length in CX}
  192.         REP     MOVSB           {Pad=AnyString}
  193.         MOV     CX, FldSize      {CX has FldSize}
  194.         XOR     CH, CH           {Make FldSize=FldSize mod 256}
  195.         MOV     ES : [BX], CL      {Make Length(Pad)=FldSize}
  196.         SUB     CX, AX           {CX=FldSize-Length(AnyString)}
  197.         JB      @1              {Return truncated string if CX<0}
  198.         MOV     AL, PadChar      {else load character to pad}
  199.         REP     STOSB           {and pad to FldSize}
  200. @1 :                             {Go back}
  201.         POP     DS              {Restore Data Segment}
  202. END;
  203.  
  204.  
  205. FUNCTION PadR (InpStr : STRING; FieldLen : BYTE) : STRING;
  206. BEGIN
  207. PadR := FixLen (InpStr, #32, FieldLen);
  208. END;
  209.  
  210. Procedure RightJustify(Var S: String; Width: Byte); Assembler;
  211. Asm
  212.    push    ds              { Save DS }
  213.    lds     si, S           { Load Pointer to String }
  214.    mov     al, [si]        { Move length Byte  in AL }
  215.    mov     ah, Width       { Move Width in AH }
  216.    sub     ah, al          { Subtract }
  217.    jbe     @Done           { if Length(S) >= Width then Done... }
  218.    push    si              { Save SI on stack }
  219.    mov     cl, al
  220.    sub     ch, ch          { CX = length of the String }
  221.    add     si, cx          { SI points to the last Character }
  222.    mov     dx, ds
  223.    mov     es, dx          { ES = DS }
  224.    mov     di, si          { DI = SI }
  225.    mov     dl, ah
  226.    sub     dh, dh          { DX = number of spaces to padd }
  227.    add     di, dx          { DI points to the new end of the String }
  228.    std                     { String ops backward }
  229.    rep     movsb           { Copy String to the new location }
  230.    pop     si              { SI points to S }
  231.    mov     di, si          { DI points to S }
  232.    add     al, ah          { AL = new length Byte }
  233.    cld                     { String ops Forward }
  234.    stosb                   { Store new length Byte }
  235.    mov     al, ' '
  236.    mov     cx, dx          { CX = number of spaces }
  237.    rep     stosb           { store spaces }
  238. @Done:
  239.    pop     ds              { Restore DS }
  240. end;
  241.  
  242. FUNCTION PadL(InpStr : STRING; Len : Byte) : STRING;
  243. BEGIN
  244. RightJustify(InpStr,Len);
  245. PadL := InpStr;
  246. END;
  247.  
  248. FUNCTION TrimB (InpStr : STRING) : STRING;
  249. BEGIN
  250. while (InpStr[0] > #0) and (InpStr[Length(InpStr)] = #32) do
  251.          Dec(InpStr[0]);  { trim left }
  252.   while (InpStr[0] > #0) and (InpStr[1] = #32) do
  253.   begin
  254.     Move(InpStr[2], InpStr[1], Pred(Length(InpStr)));
  255.     Dec(InpStr[0]);
  256.   end;
  257.   TrimB := InpStr;
  258. END;
  259.  
  260. PROCEDURE Replace (VAR S : STRING; NowChar, ReplaceChar : CHAR);
  261. VAR i    : BYTE;
  262.     SLen : BYTE ABSOLUTE S;
  263. BEGIN
  264. FOR i := 1 TO SLen DO
  265.     IF S [i] = NowChar THEN S [i] := ReplaceChar;
  266. END;
  267.  
  268.  
  269. FUNCTION GetStr (VAR InpStr : STRING; Delim : CHAR) : STRING;
  270. VAR i : INTEGER;
  271. BEGIN
  272.    i := POS (Delim, InpStr);
  273.    IF i = 0 THEN BEGIN
  274.       GetStr := InpStr;
  275.       InpStr := ''
  276.       END
  277.    ELSE BEGIN
  278.       GetStr := COPY (InpStr, 1, i - 1);
  279.       DELETE (InpStr, 1, i)
  280.       END
  281. END;
  282.  
  283. { ╔════════════════════════════════════════════════════════════════════════╗ }
  284. { ║                        PATH PROCEDURES AND FUNCTIONS                   ║ }
  285. { ╚════════════════════════════════════════════════════════════════════════╝ }
  286.  
  287. FUNCTION PathOnly (FileName : PathStr) : PathStr;
  288. VAR
  289.    Dir  : DirStr;
  290.    Name : NameStr;
  291.    Ext  : ExtStr;
  292. BEGIN
  293.    FSplit (FileName, Dir, Name, Ext);
  294.    PathOnly := Dir;
  295. END {PathOnly};
  296.  
  297. FUNCTION RootOnly (FileName : PathStr) : PathStr;
  298. VAR
  299.    Dir  : DirStr;
  300.    Name : NameStr;
  301.    Ext  : ExtStr;
  302. BEGIN
  303.    FSplit (FileName, Dir, Name, Ext);
  304.    RootOnly := COPY (Dir, 1, 2) + '\';
  305. END {RootOnly};
  306.  
  307. FUNCTION NameOnly (FileName : PathStr) : PathStr;
  308. { Strip any path information from a file specification }
  309. VAR
  310.    Dir  : DirStr;
  311.    Name : NameStr;
  312.    Ext  : ExtStr;
  313. BEGIN
  314.    FSplit (FileName, Dir, Name, Ext);
  315.    NameOnly := Name + Ext;
  316. END {NameOnly};
  317.  
  318. FUNCTION BaseNameOnly (FileName : PathStr) : PathStr;
  319. { Strip any path and extension from a file specification }
  320. VAR
  321.    Dir  : DirStr;
  322.    Name : NameStr;
  323.    Ext  : ExtStr;
  324. BEGIN
  325.    FSplit (FileName, Dir, Name, Ext);
  326.    BaseNameOnly := Name;
  327. END {BaseNameOnly};
  328.  
  329. FUNCTION ExtOnly (FileName : PathStr) : PathStr;
  330. { Strip the path and name from a file specification.  Return only the }
  331. { filename extension.                                                 }
  332. VAR
  333.    Dir  : DirStr;
  334.    Name : NameStr;
  335.    Ext  : ExtStr;
  336. BEGIN
  337.    FSplit (FileName, Dir, Name, Ext);
  338.    IF POS ('.', Ext) <> 0 THEN
  339.       DELETE (Ext, 1, 1);
  340.    ExtOnly := Ext;
  341. END {ExtOnly};
  342.  
  343. FUNCTION NameLessExt (FileName : PathStr) : PathStr;
  344. { Strip any extension from a file specification }
  345. VAR
  346.    Dir  : DirStr;
  347.    Name : NameStr;
  348.    Ext  : ExtStr;
  349. BEGIN
  350.    FSplit (FileName, Dir, Name, Ext);
  351.    NameLessExt := Dir + Name;
  352. END;
  353.  
  354. FUNCTION AddBackSlash(DirName : string) : string;
  355.   {-Add a default backslash to a directory name}
  356. begin
  357.   if DirName[Length(DirName)] in ['\',':',#0] then
  358.     AddBackSlash := DirName
  359.   else
  360.     AddBackSlash := DirName+'\';
  361. end;
  362.  
  363.  
  364. FUNCTION NoBackSlash (Path : PathStr) : PathStr;
  365. { Returns a path name that has its last backslash removed }
  366. BEGIN
  367.   IF (Path [LENGTH (Path) ] = '\') AND     { Last char of path is backslash }
  368.      (Path <> '\') AND                    { Path is not a root directory }
  369.      NOT ( (LENGTH (Path) = 3) AND (COPY (Path, 2, 2) = ':\') ) THEN
  370.     DELETE (Path, LENGTH (Path), 1);                    { Delete backslash }
  371.   NoBackSlash := Path;
  372. END; { Nobackslash }
  373.  
  374. FUNCTION StripPathName (Path : PathStr) : PathStr;
  375. {If path contains wildcard *.*,??? Then Strip away leaving only path}
  376.  
  377. VAR Temp, S : PathStr;
  378.     Wild   : BYTE;
  379.  
  380. BEGIN
  381. Path := NoBackSlash (Path);
  382. S    := PathOnly(Path);
  383. Temp := NameOnly(Path);
  384. Wild := POS ('*', Temp) + POS ('?', Temp) + POS ('.', Temp);
  385. IF Wild <> 0 THEN Path := S;
  386. IF (LENGTH (Path) = 1) AND (UPCASE (Path [1]) IN ['A'..'Z']) THEN Path := Path + ':\';
  387. IF Path [LENGTH (Path) ] <> '\' THEN Path := Path + '\';
  388. StripPathName := Path;
  389. END;
  390.  
  391.  
  392. FUNCTION FullPathname (Path, FileMask : PathStr) : PathStr;
  393.  BEGIN                     {FullPathname}
  394.  Path     := TrimB (StripPathName (Path) );
  395.  Filemask := TrimB (Filemask);
  396.  IF POS (':', FileMask) + POS ('.', FileMask) > 0 THEN FileMask := NameOnly (FileMask);
  397.  IF Path [LENGTH (Path) ] = '\' THEN
  398.     DELETE (Path, LENGTH (Path), 1);        { Delete backslash }
  399.  IF FileMask [1] = '\' THEN FileMask := COPY (FileMask, 2, LENGTH (FileMask) );
  400.  FullPathName := FExpand (Path + '\' + FileMask);
  401.  END;                      {FullPathname}
  402.  
  403. FUNCTION SameName (N1, N2 : STRING) : BOOLEAN;
  404. {
  405.   Function to compare filespecs.
  406.  
  407.   Wildcards allowed in either name.
  408.   Filenames should be compared seperately from filename extensions by using
  409.      seperate calls to this function
  410.         e.g.  FName1.Ex1
  411.               FName2.Ex2
  412.               are they the same?
  413.               they are if SameName(FName1, FName2) AND SameName(Ex1, Ex2)
  414.  
  415.   Wildcards work the way DOS should've let them work (eg. *XX.DAT doesn't
  416.   match just any file...only those with 'XX' as the last two characters of
  417.   the name portion and 'DAT' as the extension).
  418.  
  419.   This routine calls itself recursively to resolve wildcard matches.
  420.  
  421. }
  422. VAR
  423.    P1, P2 : INTEGER;
  424.    Match  : BOOLEAN;
  425. BEGIN
  426.    P1    := 1;
  427.    P2    := 1;
  428.    Match := TRUE;
  429.  
  430.    IF (LENGTH (N1) = 0) AND (LENGTH (N2) = 0) THEN
  431.       Match := TRUE
  432.    ELSE
  433.       IF LENGTH (N1) = 0 THEN
  434.          IF N2 [1] = '*' THEN
  435.             Match := TRUE
  436.          ELSE
  437.             Match := FALSE
  438.       ELSE
  439.          IF LENGTH (N2) = 0 THEN
  440.             IF N1 [1] = '*' THEN
  441.                Match := TRUE
  442.             ELSE
  443.                Match := FALSE;
  444.  
  445.    WHILE (Match = TRUE) AND (P1 <= LENGTH (N1) ) AND (P2 <= LENGTH (N2) ) DO
  446.       IF (N1 [P1] = '?') OR (N2 [P2] = '?') THEN BEGIN
  447.          INC (P1);
  448.          INC (P2);
  449.       END {then}
  450.       ELSE
  451.          IF N1 [P1] = '*' THEN BEGIN
  452.             INC (P1);
  453.             IF P1 <= LENGTH (N1) THEN BEGIN
  454.                WHILE (P2 <= LENGTH (N2) ) AND NOT SameName (COPY (N1, P1, LENGTH (N1) - P1 + 1),COPY(N2,P2,LENGTH(N2)-P2+1)) DO
  455.                   INC (P2);
  456.                IF P2 > LENGTH (N2) THEN
  457.                   Match := FALSE
  458.                ELSE BEGIN
  459.                   P1 := SUCC (LENGTH (N1) );
  460.                   P2 := SUCC (LENGTH (N2) );
  461.                END {if};
  462.             END {then}
  463.             ELSE
  464.                P2 := SUCC (LENGTH (N2) );
  465.          END {then}
  466.          ELSE
  467.             IF N2 [P2] = '*' THEN BEGIN
  468.                INC (P2);
  469.                IF P2 <= LENGTH (N2) THEN BEGIN
  470.                   WHILE (P1 <= LENGTH (N1) ) AND NOT SameName (COPY (N1, P1, LENGTH (N1)-P1+1),COPY(N2, P2,LENGTH(N2)-P2+1)) DO
  471.                      INC (P1);
  472.                   IF P1 > LENGTH (N1) THEN
  473.                      Match := FALSE
  474.                   ELSE BEGIN
  475.                      P1 := SUCC (LENGTH (N1) );
  476.                      P2 := SUCC (LENGTH (N2) );
  477.                   END {if};
  478.                END {then}
  479.                ELSE
  480.                   P1 := SUCC (LENGTH (N1) );
  481.             END {then}
  482.             ELSE
  483.                IF UPCASE (N1 [P1]) = UPCASE (N2 [P2]) THEN BEGIN
  484.                   INC (P1);
  485.                   INC (P2);
  486.                END {then}
  487.                ELSE
  488.                   Match := FALSE;
  489.  
  490.    IF P1 > LENGTH (N1) THEN BEGIN
  491.       WHILE (P2 <= LENGTH (N2) ) AND (N2 [P2] = '*') DO
  492.          INC (P2);
  493.       IF P2 <= LENGTH (N2) THEN
  494.          Match := FALSE;
  495.    END {if};
  496.  
  497.    IF P2 > LENGTH (N2) THEN BEGIN
  498.       WHILE (P1 <= LENGTH (N1) ) AND (N1 [P1] = '*') DO
  499.          INC (P1);
  500.       IF P1 <= LENGTH (N1) THEN
  501.          Match := FALSE;
  502.    END {if};
  503.  
  504.    SameName := Match;
  505.  
  506. END {SameName};
  507.  
  508. FUNCTION Exist (FName : PathStr; GoodAttr : WORD) : BOOLEAN;
  509.     {-Return true if file is found and attribute matches }
  510.   VAR
  511.     Regs : REGISTERS;
  512.     FLen : BYTE ABSOLUTE FName;
  513.   BEGIN
  514.     {check for empty string}
  515.     IF LENGTH (FName) = 0 THEN Exist := FALSE
  516.     ELSE WITH Regs DO
  517.     BEGIN
  518.       IF IORESULT = 0 THEN ; {clear IoResult}
  519.       INC (FLen);
  520.       FName [FLen] := #0;
  521.       AX := $4300;           {get file attribute}
  522.       DS := SEG (FName);
  523.       DX := OFS (FName [1]);
  524.       MSDOS (Regs);
  525.       Exist := (NOT ODD (Flags) ) AND (IORESULT = 0) AND
  526.                    (CX AND GoodAttr <> 0);
  527.     END;
  528.   END;
  529.  
  530.  
  531. { ╔════════════════════════════════════════════════════════════════════════╗ }
  532. { ║                           SORTING FUNCTIONS                            ║ }
  533. { ╚════════════════════════════════════════════════════════════════════════╝ }
  534.  
  535.  
  536. FUNCTION LessName (X, Y : DirPtr) : BOOLEAN;
  537. BEGIN
  538.   LessName := X^.Name < Y^.Name;
  539. END;
  540.  
  541. FUNCTION LessExt (X, Y : DirPtr) : BOOLEAN;
  542. VAR P   : BYTE;
  543.     E, E1 : STRING [3];
  544. BEGIN
  545.     P := POS ('.', X^.Name);
  546.     IF P > 1 THEN E := COPY (X^.Name, P + 1, 3)
  547.     ELSE E := '';
  548.  
  549.     P := POS ('.', Y^.Name);
  550.     IF P > 1 THEN E1 := COPY (Y^.Name, P + 1, 3)
  551.     ELSE E1 := '';
  552.   LessExt := E < E1;
  553. END;
  554.  
  555. FUNCTION LessPath (X, Y : DirPtr) : BOOLEAN;
  556. BEGIN
  557.   LessPath := X^.Path < Y^.Path;
  558. END;
  559.  
  560. FUNCTION LessSize (X, Y : DirPtr) : BOOLEAN;
  561. BEGIN
  562.   LessSize := X^.Size < Y^.Size;
  563. END;
  564.  
  565. FUNCTION LessTime (X, Y : DirPtr) : BOOLEAN;
  566. BEGIN
  567.   LessTime := X^.Time < Y^.Time;
  568. END;
  569.  
  570. FUNCTION LessAttr (X, Y : DirPtr) : BOOLEAN;
  571. BEGIN
  572.   LessAttr := X^.Attr < Y^.Attr;
  573. END;
  574.  
  575. PROCEDURE QuickSort (L, R : INTEGER; VAR Page : SortPage; Less : LessFunc);
  576. VAR
  577.   I, J : INTEGER;
  578.   X    : DirPtr;
  579.  
  580.   PROCEDURE ExchangeStructs(var I, J; Size : Word);
  581.     inline(
  582.       $FC/                     {cld             ;go forward}
  583.       $8C/$DA/                 {mov dx,ds       ;save DS}
  584.       $59/                     {pop cx          ;CX = Size}
  585.       $5E/                     {pop si}
  586.       $1F/                     {pop ds          ;DS:SI => J}
  587.       $5F/                     {pop di}
  588.       $07/                     {pop es          ;ES:DI => I}
  589.       $D1/$E9/                 {shr cx,1        ;move by words}
  590.       $E3/$0C/                 {jcxz odd}
  591.       $9C/                     {pushf}
  592.                                {start:}
  593.       $89/$F3/                 {mov bx,si}
  594.       $26/$8B/$05/             {mov ax,es:[di]  ;exchange words}
  595.       $A5/                     {movsw}
  596.       $89/$07/                 {mov [bx],ax}
  597.       $E2/$F6/                 {loop start      ;again?}
  598.       $9D/                     {popf}
  599.                                {odd:}
  600.       $73/$07/                 {jnc exit}
  601.       $8A/$04/                 {mov al,[si]     ;exchange the odd bytes}
  602.       $26/$86/$05/             {xchg al,es:[di]}
  603.       $88/$04/                 {mov [si],al}
  604.                                {exit:}
  605.       $8E/$DA);                {mov ds,dx       ;restore DS}
  606.  
  607. BEGIN
  608.   I := L;
  609.   J := R;
  610.   X := Page [ (L + R) DIV 2];
  611.   REPEAT
  612.     WHILE Less (Page [I], X) DO INC (I);
  613.     WHILE Less (X, Page [J]) DO DEC (J);
  614.     IF I <= J THEN
  615.     BEGIN
  616.       ExchangeStructs (Page [I], Page [J], SIZEOF (DirPtr) );
  617.       INC (I);
  618.       DEC (J);
  619.     END;
  620.   UNTIL I > J;
  621.   IF L < J THEN QuickSort (L, J, Page, Less);
  622.   IF I < R THEN QuickSort (I, R, Page, Less);
  623. END;
  624.  
  625. { ╔════════════════════════════════════════════════════════════════════════╗ }
  626. { ║                 INTERFACED PROCEDURES AND FUNCTIONS                    ║ }
  627. { ╚════════════════════════════════════════════════════════════════════════╝ }
  628.  
  629. FUNCTION FileTypePerExtension(fName : PathStr) : FileTypes;
  630.  
  631. VAR
  632.      Ext : ExtStr;
  633.  
  634. BEGIN
  635.    Ext := ExtOnly(Uppercase(fName));
  636.    IF (fName = '.') OR (fName = '..') OR (fName = '\') OR
  637.    (POS('\.',fName) + POS('..',fName) > 0) THEN
  638.    FileTypePerExtension := fDIR ELSE
  639.    IF (POS(Ext,'.ARC.PAK.ZIP.LZH.ARJ.ZOO.LBR.COM.EXE.BAT') = 0) THEN
  640.    FileTypePerExtension := fOTHER ELSE
  641.    FileTypePerExtension := FILETYPES(POS(Ext,'.ARC.PAK.ZIP.LZH.ARJ.ZOO.LBR.COM.EXE.BAT') div 4);
  642. END;
  643.  
  644. FUNCTION FileTypeString (FT : FileTypes) : STRING;
  645. BEGIN
  646. CASE FT OF
  647.     fARC   : FileTypeString := 'ARC';
  648.     fPAK   : FileTypeString := 'PAK';
  649.     fZIP   : FileTypeString := 'ZIP';
  650.     fLBR   : FileTypeString := 'LBR';
  651.     fZOO   : FileTypeString := 'ZOO';
  652.     fLZH   : FileTypeString := 'LZH';
  653.     fARJ   : FileTypeString := 'ARJ';
  654.     fCOM   : FileTypeString := 'COM';
  655.     fEXE   : FileTypeString := 'EXE';
  656.     fBAT   : FileTypeString := 'BATCH';
  657.     fSFX   : FileTypeString := 'SFX';
  658.     fDIR   : FileTypeString := 'DIR';
  659.     fVOL   : FileTypeString := 'VOLUME';
  660.     fOTHER : FileTypeString := 'FILE';
  661.     fERROR : FileTypeString := 'ERROR';
  662.     ELSE FileTypeString := '';
  663.     END;
  664. END;
  665.  
  666. FUNCTION GetArcType (FName : PathStr) : FileTypes;
  667. VAR
  668.   ArcFile : FILE;
  669.   i       : INTEGER;
  670.   Gat     : FileTypes;
  671.   c       : ARRAY [1..5] OF BYTE;
  672. BEGIN
  673.   ASSIGN (ArcFile, FName);
  674.   RESET  (ArcFile,1);
  675.   IF IORESULT <> 0 THEN
  676.     Gat := fError
  677.   ELSE
  678.   IF FILESIZE (ArcFile) < 5 THEN
  679.     Gat := fError
  680.   ELSE
  681.   BEGIN
  682.     BLOCKREAD (ArcFile, c , 5);
  683.     CLOSE (ArcFile);
  684.     IF ( (c [1] = $50) AND (c [2] = $4B) ) THEN
  685.       Gat := fZip
  686.     ELSE
  687.     IF ( (c [1] = $60) AND (c [2] = $EA) ) THEN
  688.       Gat := fArj
  689.     ELSE
  690.     IF ( (c [4] = $6c) AND (c [5] = $68) ) THEN
  691.       Gat := fLzh
  692.     ELSE
  693.     IF ( (c [1] = $5a) AND (c [2] = $4f) AND (c [3] = $4f) ) THEN
  694.       Gat := fZoo
  695.     ELSE
  696.     IF ( (c [1] = $1a) AND (c [2] = $08) ) THEN
  697.       Gat := fArc
  698.     ELSE
  699.     IF ( (c [1] = $1a) AND (c [2] = $0b) ) THEN
  700.       Gat := fPak
  701.     ELSE
  702.       Gat := fOTHER;
  703.   END;
  704.  
  705.   GetArcType := Gat;
  706. END;
  707.  
  708. FUNCTION MethodString (Method : BYTE) : STRING;
  709. CONST
  710.     Stowage : ARRAY [0..12] OF STRING [9] =
  711.       ('Stored', 'Shrunk', 'Stored', 'Packed', 'Squeezed', 'LZCrunch', 'LZCrunch',
  712.       'LZW Pack', 'Crunched', 'Squashed', 'Crushed', 'Distilled', 'Frozen');
  713. BEGIN
  714. IF Method <= 12 THEN MethodString := PadR (Stowage [Method], 9)
  715.    ELSE MethodString := '';
  716. END;
  717.  
  718. PROCEDURE GetCommandLine (VAR Mask : PathStr);
  719. VAR
  720.    i : BYTE;
  721. BEGIN
  722.   Mask := '';
  723.   IF PARAMCOUNT = 0 THEN EXIT;
  724.   FOR I := 1 TO PARAMCOUNT DO Mask := Mask + ' ' + PARAMSTR (i);
  725.   Mask := TrimB (UpperCase (Mask) );
  726. END;
  727.  
  728. PROCEDURE UpdateNextPrev (VAR Dir : DirList);
  729. { This ASSUMES that Dirs is The LAST record added }
  730. VAR
  731.    Work : DirPtr;
  732. BEGIN
  733.     Dir.Current^.Next := NIL;
  734.     Dir.Current^.Prev := NIL;
  735.     IF Dir.Root = NIL THEN Dir.Root := Dir.Current
  736.     ELSE BEGIN
  737.          Work := Dir.Root;
  738.          WHILE (Work^.Next <> NIL) DO Work := Work^.Next;
  739.          Work^.Next     := Dir.Current;
  740.          Dir.Current^.Prev := Work;
  741.          Dir.Current^.Next := NIL;
  742.          END;
  743. Dir.Last    := Dir.Current;
  744. END;
  745.  
  746. FUNCTION  NthDirItem (VAR Dir : DirList; Item : INTEGER) : DirPtr;
  747. { return nth dir item in list .. ZERO if the FIRST ITEM }
  748. VAR
  749.     W : DirPtr;
  750.     C : INTEGER;
  751. BEGIN
  752. NthDirItem := NIL;
  753. IF Item > Dir.Count THEN EXIT;
  754. C := 0;
  755. W := Dir.Root;
  756. WHILE ( W <> NIL ) AND (C < Item) DO
  757.       BEGIN
  758.       INC (C);
  759.       W := W^.Next;
  760.       END;
  761. NthDirItem := W;
  762. END;
  763.  
  764. FUNCTION IsDir(fName : PathStr) : BOOLEAN;
  765. BEGIN
  766. IsDir := Exist(fName,Directory);
  767. END;
  768.  
  769. FUNCTION IsArchive(fName : PathStr) : BOOLEAN;
  770. BEGIN
  771. IsArchive := NOT (GetArcType(fName) in [fOTHER,fERROR]);
  772. END;
  773.  
  774. PROCEDURE FindFiles (VAR Dir : DirList; SearchPath : PathStr);
  775. { find files matching MASK on PATH }
  776.  
  777. VAR  F : SearchRec;
  778.  
  779.      FUNCTION IsDirectory(dPath : SearchRec) : BOOLEAN;
  780.      BEGIN
  781.      IsDirectory := (dPath.Attr = 16) AND (POS ('.',dPath.Name) = 0);
  782.      END;
  783.  
  784.      FUNCTION IsGoodFile (dFile : SearchRec) : BOOLEAN;
  785.      VAR
  786.          i : BYTE;
  787.          Check,
  788.          TempMask : STRING;
  789.  
  790.      BEGIN
  791.  
  792.      IsGoodFile := TRUE;
  793.  
  794.      IF Dir.Mask = '*.*' THEN EXIT;  { we want ALL of them }
  795.  
  796.      IsGoodFile := FALSE;
  797.      TempMask   := Dir.Mask;
  798.  
  799.      WHILE TempMask <> '' DO
  800.          BEGIN
  801.          Check := GetStr(TempMask,#32);
  802.          IF Check = '' THEN EXIT;
  803.          IF SameName (Check, dFile.Name) OR
  804.             (Check = '*.*') THEN
  805.             BEGIN
  806.             IsGoodFile := TRUE;
  807.             EXIT;
  808.             END;
  809.          END;
  810.  
  811.      END;
  812.  
  813. BEGIN
  814.  
  815.   WITH Dir DO
  816.   BEGIN
  817.   IF Dir.Mask = '' THEN Dir.Mask := '*.*';
  818.   FINDFIRST (FullPathName (SearchPath, '*.*'), AnyFile, F);
  819.   WHILE (DosError = 0) AND (Count < MaxDirSize) DO
  820.   BEGIN
  821.     IF IsGoodFile (F) AND ( POS (SilentDirStr, F.Name) = 0 ) AND
  822.        (MaxAvail > SizeOf (DirRec) + 1024) THEN
  823.        BEGIN
  824.        GETMEM (Current , SIZEOF (DirRec) );
  825.        Current^.Attr  := F.Attr;
  826.        Current^.Time  := F.Time;
  827.        Current^.Size  := F.Size;
  828.        Current^.Name  := F.Name;
  829.        Current^.Path  := SearchPath;
  830.        IF (F.Attr AND Directory <> 0) THEN
  831.        Current^.FType := fDIR ELSE
  832.        IF (F.Attr AND VolumeID <> 0) THEN
  833.        Current^.FType := fVOL ELSE
  834.        Current^.FType := FileTypePerExtension(F.Name);
  835.        Current^.Tag   := FALSE;
  836.        UpdateNextPrev (Dir);
  837.        INC (Dir.Count);
  838.        INC (Dir.Space, F.Size);
  839.        END ELSE IF IsDirectory(F) AND (Dir.Recurse) THEN
  840.                    FindFiles(Dir,FullPathName(SearchPath,F.Name));
  841.   FINDNEXT (F);
  842.   END;
  843.  
  844.   END; { With }
  845. END;
  846.  
  847. PROCEDURE SortFiles (VAR Dir : DirList);
  848. VAR
  849.    Page : sortPPtr;
  850.    Idx  : INTEGER;
  851.    W    : DirPtr;
  852.  
  853. BEGIN
  854.  
  855.   IF (Dir.Count <> 0) AND (@Dir.Less <> NIL) THEN
  856.       BEGIN
  857.       New(Page);
  858.       FILLCHAR (Page^, SIZEOF (Sortpage), #0);
  859.       Idx := 0;
  860.       W   := Dir.Root;
  861.       FOR Idx := 0 TO PRED (Dir.Count) DO
  862.          BEGIN
  863.          Page^ [idx] := W;
  864.          W         := W^.Next;
  865.          END;
  866.  
  867.       QuickSort ( 0, idx, Page^, Dir.Less );
  868.  
  869.       Dir.Root := NIL;
  870.       Dir.Last := NIL;
  871.       Dir.Current := NIL;
  872.  
  873.       FOR Idx := 0 TO PRED (Dir.Count) DO
  874.           BEGIN
  875.           Dir.Current := Page^ [idx];
  876.           UpdatenextPrev (Dir);
  877.           END;
  878.  
  879.       Dispose(Page);
  880.       END;
  881.  
  882. END;
  883.  
  884. PROCEDURE SetLess (VAR Dir : DirList; LChar : CHAR);
  885. BEGIN
  886.   CASE LoCase (LChar) OF
  887.    'n' : Dir.Less := LessName;
  888.    'e' : Dir.Less := LessExt;
  889.    'a' : Dir.Less := LessAttr;
  890.    'd' : Dir.Less := LessTime;
  891.    's' : Dir.Less := LessSize;
  892.    'p' : Dir.Less := LessPath;
  893.     ELSE Dir.Less := LessName;
  894.  END; { case }
  895. CurrentLess := LChar;
  896. END;
  897.  
  898. PROCEDURE InitializeDir (VAR Dir : DirList);
  899.  
  900. BEGIN
  901.   FILLCHAR (Dir, SIZEOF (DirRec), #0);
  902.   Dir.Root := NIL;
  903.   Dir.Last := NIL;
  904.   Dir.Current := NIL;
  905.   SetLess (Dir, CurrentLess);
  906.   GETDIR (0, Dir.Path);
  907. END;
  908.  
  909. PROCEDURE ReleaseFiles (VAR Dir : DirList);
  910.  
  911. VAR
  912.   I : INTEGER;
  913.   W : DirPtr;
  914.  
  915. BEGIN
  916.  
  917.   IF Dir.Count > 0 THEN
  918.   BEGIN
  919.   W := Dir.Root;
  920.   FOR I := 0 TO PRED (Dir.Count) DO
  921.       BEGIN
  922.       Dir.Current := W;
  923.       IF W <> NIL THEN FREEMEM (W, SIZEOF (DirRec) );
  924.       W := dir.Current^.Next;
  925.       END;
  926.   END;
  927.  
  928.   { Do Not Want to initialize all of it }
  929.  
  930.   Dir.Count   := 0;
  931.   Dir.Space   := 0;
  932.   Dir.Tagged  := 0;
  933.   Dir.TSpace  := 0;
  934.   Dir.Root    := NIL;
  935.   Dir.Last    := NIL;
  936.   Dir.Current := NIL;
  937.  
  938.  
  939. END;
  940.  
  941. FUNCTION DosTime (Date, Time : WORD) : LONGINT;
  942.  
  943.   VAR
  944.     DT : DateTime;
  945.     FT : LONGINT;
  946.  
  947. BEGIN
  948.  
  949.     WITH DT DO
  950.          BEGIN
  951.          day   := date AND $001F;
  952.          month := (date SHR 5) AND $000F;
  953.          year  := ( (date SHR 9 + 80) MOD 100) + 1900;
  954.  
  955.          min    := (time SHR 5) AND $003F;
  956.          hour   := time SHR 11;
  957.          Sec    := 0;
  958.          END;
  959.  
  960. PACKTIME (DT, FT);
  961. DosTime := FT;
  962. END;
  963.  
  964.  
  965. PROCEDURE SaveArchiveEntry ( VAR  Dir       : DirList;
  966.                                   File_Name : PathStr;
  967.                                   File_Path : PathStr;
  968.                                   Size_Now  : LONGINT;
  969.                                   Size_Then : LONGINT;
  970.                                   File_Time : LONGINT;
  971.                                   MethodStr : STRING);
  972. BEGIN
  973.  
  974.  
  975.           WITH Dir DO
  976.           BEGIN
  977.             GETMEM (Current, SIZEOF (DirRec) );
  978.             Current ^.Attr   := 32;
  979.             Current ^.Time   := File_Time;
  980.             Current ^.Size   := Size_Then;
  981.             Current ^.PSize  := Size_Now;
  982.             Current ^.Method := MethodStr;
  983.             Current ^.Name   := PadR (File_Name, 12);
  984.             Current ^.Path   := NoBackSlash (File_Path);
  985.             IF Current ^.Path <> '' THEN
  986.                BEGIN
  987.                IF (Current ^.Path [1] <> '\') AND
  988.                   (POS (':\', Current ^.Path) = 0) THEN
  989.                   Current ^.Path := '\' + Current ^.Path;
  990.                END;
  991.             Current^.FType   := FileTypePerExtension(File_Name);
  992.             Current ^.Tag    := FALSE;
  993.             UpdateNextPrev (Dir);
  994.             INC (Dir.Count);
  995.             INC (Dir.Space, Size_Then);
  996.             END;
  997.  
  998. END { SaveArchiveEntry };
  999.  
  1000. Procedure ZipView(VAR Dir : DirList; ZIPFile : String);  { View the ZIP File }
  1001. Const
  1002.   SIG = $04034B50;                  { Signature }
  1003. Type
  1004.   ZFHeader = Record                 { Zip File Header }
  1005.     Signature  : LongInt;
  1006.     Version,
  1007.     GPBFlag,
  1008.     Compress,
  1009.     Time,Date  : Word;
  1010.     CRC32,
  1011.     CSize,
  1012.     USize      : LongInt;
  1013.     FNameLen,
  1014.     ExtraField : Word;
  1015.   end;
  1016.  
  1017. Var
  1018.   Hdr     : ^ZFHeader;
  1019.   F       : File;
  1020.   S       : String;
  1021.  
  1022.   Label Terminate;
  1023.  
  1024. Const
  1025.   CompTypes : Array[0..7] of String[9] =
  1026.               ('Stored ','Shrunk   ','Reduced1','Reduced2','Reduced3',
  1027.                'Reduced4','Imploded ','Deflated');
  1028.   { Method used to compress }
  1029.  
  1030. begin
  1031.  
  1032.   New(Hdr);
  1033.   Assign(F,ZIPFile);
  1034.   {$I-}
  1035.   Reset(F,1);                            { Open File }
  1036.   {$I+}
  1037.   If IOResult <> 0 then GOTO Terminate;  { Couldn't open Zip File }
  1038.  
  1039.   Repeat
  1040.     FillChar(S,SizeOf(S), #0);  { Pad With nulls }
  1041.     BlockRead(F,Hdr^,SizeOf(ZFHeader));
  1042.  
  1043.     { Read File Header }
  1044.     BlockRead(F,Mem[Seg(S) : Ofs(S) + 1], Hdr^.FNameLen);
  1045.     s[0] := Chr(Hdr^.FNameLen);
  1046.  
  1047.   IF (Hdr^.Signature = Sig) Then { Is a header }
  1048.   SaveArchiveEntry(Dir,NameOnly(S),PathOnly(S),Hdr^.CSize,Hdr^.USize,DosTime(Hdr^.Date,Hdr^.Time),CompTypes[Hdr^.Compress]);
  1049.  
  1050.   Seek(F,FilePos(F) + Hdr^.CSize + Hdr^.ExtraField);
  1051.   Until Hdr^.Signature <> SIG; { No more Files }
  1052.  
  1053.   TERMINATE :
  1054.  
  1055.   Close(F);
  1056.   Dispose(Hdr);
  1057. end;
  1058.  
  1059. PROCEDURE ArjView(VAR Dir : DirList; ArjFile : String);
  1060.  
  1061. Type
  1062.   AFHeader = Record  { ArjFileHeader }
  1063.     HeadID,
  1064.     HdrSize   : Word;
  1065.     HeadSize,
  1066.     VerNum,
  1067.     MinVerNum,
  1068.     HostOS,
  1069.     ArjFlag,
  1070.     Method,
  1071.     FType,
  1072.     Reserved  : Byte;
  1073.     FileTime,
  1074.     PackSize,
  1075.     OrigSize,
  1076.     FileCRC   : LongInt;
  1077.     FilePosF,
  1078.     FileAcc,
  1079.     HostData  : Word;
  1080.   end;
  1081.  
  1082. Var
  1083.   b      : Byte;
  1084.   f      : File;
  1085.   sl     : LongInt;
  1086.   NR     : Word;
  1087.   FHdr   : ^AFHeader;
  1088.   s      : String;
  1089.   l      : String[80];
  1090.   i,e,ff : Integer;
  1091.  
  1092.   Label Terminate;
  1093.  
  1094. Const
  1095.   CompTypes : Array[0..4] of String[9] = ('Stored','Most',
  1096.               '2nd Most','2nd Fast','Fastest');
  1097.  
  1098.  
  1099. begin
  1100.  
  1101.   New(FHdr);
  1102.   Assign(f, arjFile);
  1103.   {$I-}
  1104.   Reset(F, 1);                     { Open File }
  1105.   {$I+}
  1106.   If IOResult <> 0 then GOTO Terminate; { Specified File exists?}
  1107.   SL := 0;
  1108.   FF := 0;
  1109.   Repeat
  1110.  
  1111.     Inc(FF);
  1112.     Seek(F,SL);
  1113.     BlockRead(F,FHdr^,SizeOf(AFHeader),NR);     { Read the header }
  1114.  
  1115.     If (NR = SizeOf(AFHeader)) Then
  1116.     BEGIN
  1117.       s := '';
  1118.       Repeat
  1119.         BlockRead(F,B,1);               { Get Char For Compressed Filename }
  1120.         If B <> 0 Then
  1121.           s := s + Chr(b);              { Put Char in String }
  1122.       Until B = 0;                      { Until no more Chars }
  1123.  
  1124.     L := GetStr(S,'/');
  1125.     IF S = '' THEN S := L;              { draw off path info }
  1126.     IF S = L THEN L := '';
  1127.  
  1128.     IF FF > 1 THEN
  1129.     SaveArchiveEntry(Dir,S,L,FHdr^.PackSize,FHdr^.OrigSize,FHdr^.Filetime,CompTypes[FHdr^.Method])
  1130.     ELSE FHdr^.Packsize := 0;  { Main Header - DO NOT WANT }
  1131.  
  1132.       Repeat
  1133.         BlockRead(F,B,1);
  1134.       Until b = 0;
  1135.       BlockRead(F,FHdr^.FileCRC,4);      { Go past File CRC }
  1136.       BlockRead(f,NR,2);
  1137.  
  1138.       SL := FilePos(F) + FHdr^.PackSize; { Where are we in File? }
  1139.  
  1140.   END;
  1141.  
  1142.   Until (FHdr^.HdrSize = 0);  { No more Files? }
  1143.  
  1144. TERMINATE :
  1145.  
  1146.   Close(f);
  1147.   Dispose(FHdr);  { Done }
  1148. end;
  1149.  
  1150. PROCEDURE LzhView(VAR Dir : DirList; LzhFile : String);
  1151.  
  1152. Type
  1153.   FileheaderType = Record  { Lzh File header }
  1154.     Headsize,
  1155.     Headchk   : Byte;
  1156.     HeadID    : packed Array[1..5] of Char;
  1157.     Packsize,
  1158.     Origsize,
  1159.     Filetime  : LongInt;
  1160.     Attr      : Word;
  1161.     Filename  : String[12];
  1162.     f32       : PathStr;
  1163.     dt        : DateTime;
  1164.   end;
  1165.  
  1166. Var
  1167.  
  1168.   Fh         : FileheaderType;
  1169.   Fha        : Array[1..sizeof(FileheaderType)] of Byte Absolute fh;
  1170.   crc        : Word;   { CRC value }
  1171.   crcbuf     : Array[1..2] of Byte Absolute CRC;
  1172.   crc_table  : Array[0..255] of Word; { Table of CRC's }
  1173.   inFile     : File; { File to be processed }
  1174.  
  1175.   oldFilepos : LongInt;
  1176.   numread,i  : Word;
  1177.  
  1178.   Label TERMINATE;
  1179.  
  1180. Procedure Make_crc_table;
  1181. Var
  1182.   i,
  1183.   index,
  1184.   ax    : Word;
  1185.   carry : Boolean;
  1186. begin
  1187.   index := 0;
  1188.   Repeat
  1189.     ax := index;
  1190.     For i := 1 to 8 do
  1191.     begin
  1192.       carry := odd(ax);
  1193.       ax := ax shr 1;
  1194.       if carry then
  1195.         ax := ax xor $A001;
  1196.     end;
  1197.     crc_table[index] := ax;
  1198.     inc(index);
  1199.   Until index > 255;
  1200. end;
  1201.  
  1202. { use this to calculate the CRC value of the original File }
  1203. { call this Function afer reading every Byte from the File }
  1204. Procedure calccrc(data : Byte);
  1205. Var
  1206.   index : Integer;
  1207. begin
  1208.   crcbuf[1] := crcbuf[1] xor data;
  1209.   index := crcbuf[1];
  1210.   crc := crc shr 8;
  1211.   crc := crc xor crc_table[index];
  1212. end;
  1213.  
  1214.  
  1215. Function Mksum : Byte;  {calculate check sum For File header }
  1216. Var
  1217.   i : Integer;
  1218.   b : Byte;
  1219. begin
  1220.   b := 0;
  1221.   For i := 3 to fh.headsize+2 do
  1222.     b := b+fha[i];
  1223.   mksum := b;
  1224. end;
  1225.  
  1226. begin
  1227.   assign(inFile,LZHFile);
  1228.   {$I-}
  1229.   reset(inFile,1);   { Open LZH File }
  1230.   {$I+}
  1231.   If IOResult <> 0 then GOTO Terminate;   { Specified File exists? }
  1232.   oldFilepos := 0;       { Init Variables }
  1233.   Repeat
  1234.     seek(inFile,oldFilepos);
  1235.     {Goto start of File}
  1236.     blockread(inFile,fha,sizeof(FileheaderType),numread);
  1237.     {Read Fileheader}
  1238.     oldFilepos := oldFilepos+fh.headsize+2+fh.packsize;
  1239.     { Where are we? }
  1240.     i := Mksum; { Get the checksum }
  1241.  
  1242.     if fh.headsize <> 0 then
  1243.     begin
  1244.  
  1245.       if i <> fh.headchk then
  1246.       begin
  1247.         Writeln('Error in File. Unable to read.  Aborting...');
  1248.         GOTO Terminate;
  1249.       end;
  1250.  
  1251.     SaveArchiveEntry(Dir,NameOnly(Fh.Filename),PathOnly(Fh.Filename),FH.PackSize,FH.OrigSize,FH.Filetime,'Frozen')
  1252.     end;
  1253.   Until   (fh.headsize=0);
  1254.  
  1255.   TERMINATE :
  1256.   Close(infile);
  1257.  
  1258. END;
  1259.  
  1260. PROCEDURE ArcView(VAR Dir : DirList; ArcName : PathStr);
  1261.  
  1262. Type ARCHead = Record
  1263.                  ARCMark   : Char;
  1264.                  ARCVer    : Byte;
  1265.                  FN        : Array[1..13] of Char;
  1266.                  CompSize  : LongInt;
  1267.                  Dos_DT    : LongInt;
  1268.                  CRC       : Word;
  1269.                  UCompSize : LongInt;
  1270.                end;
  1271. Const ARCFlag : Char = #26;                                        { ARC mark }
  1272.       Stowage : ARRAY [0..12] OF STRING [9] =
  1273.        ('Stored', 'Shrunk', 'Stored', 'Packed', 'Squeezed', 'LZCrunch', 'LZCrunch',
  1274.        'LZW Pack', 'Crunched', 'Squashed', 'Crushed', 'Distilled', 'Frozen');
  1275.  
  1276. Var WLV   : LongInt;                               { Working LongInt Variable }
  1277.     ARC1  : ARCHead;
  1278.     QUIT  : Boolean;                             { "end" sentinel encountered }
  1279.     F     : File;
  1280.     I,
  1281.     Res   : Word;
  1282.     FSize,
  1283.     C     : LongInt;
  1284.     SName : PathStr;
  1285.     BUFF  : Array[1..4096] of Byte;
  1286.  
  1287. Procedure GET_ARC_ENTRY;
  1288. begin
  1289.   FillChar(ARC1,SizeOf(ARCHead),#0);
  1290.   Seek (F,C);
  1291.   BlockRead (F,BUFF,SizeOf(ARCHead),RES);
  1292.   Move (BUFF[1],ARC1,SizeOf(ARCHead));
  1293.   With ARC1 do
  1294.     if (ARCMark = ARCFlag) and (ARCVer > 0) then
  1295.       begin
  1296.         SNAME := '';
  1297.         I := 1;
  1298.         While FN[I] <> #0 do
  1299.           begin
  1300.             SNAME := SNAME+FN[I]; Inc(I)
  1301.           end;
  1302.         WLV := (Dos_DT Shr 16)+(Dos_DT Shl 16);              { flip Date/Time }
  1303.         FSize := CompSize;
  1304.       end;
  1305.     QUIT := ARC1.ARCVer <= 0;
  1306. end;  { GET_ARC_ENTRY }
  1307.  
  1308. begin
  1309.   Assign (F,ArcName);
  1310.   Reset (F,1);
  1311.   C := 0;
  1312.   Repeat
  1313.     GET_ARC_ENTRY;
  1314.     if not QUIT then
  1315.        SaveArchiveEntry(Dir,NameOnly(Sname),PathOnly(Sname),ARC1.CompSize,ARC1.UCompSize,WLV,Stowage[ARC1.ArcVer]);
  1316.     Inc (C,FSize+SizeOf(ARCHead))
  1317.   Until QUIT;
  1318.   Close (F);
  1319. end;
  1320.  
  1321. PROCEDURE GetFiles(VAR Dir : DirList; Path,Mask : PathStr; Sort : LessFunc);
  1322. { get either Directory or Archive depending on file type and store in list }
  1323. VAR
  1324.     Default : FileTypes;
  1325.  
  1326. BEGIN
  1327.  
  1328.   InitializeDir (Dir);
  1329.   Dir.Less    := Sort;
  1330.   Dir.Mask    := Mask;
  1331.   Dir.Path    := AddBackSlash(Path);
  1332.   Dir.ArcType := fDIR;
  1333.  
  1334.   IF IsDir(Path) Then FindFiles(Dir,Path) ELSE
  1335.      BEGIN
  1336.      Default := GetArcType(Path);
  1337.      Case Default OF
  1338.      fARC : ArcView(Dir,Path);
  1339.      fPAK : ArcView(Dir,Path);
  1340.      fZIP : ZipView(Dir,Path);
  1341.      fARJ : ArjView(Dir,Path);
  1342.      fLZH : LzhView(Dir,Path);
  1343.      END;
  1344.      Dir.ArcType := Default;
  1345.      END;
  1346.  
  1347.   { load current path if filename isn't dir or archive }
  1348.  
  1349.   IF Dir.Count > 0 THEN SortFiles(Dir) ELSE
  1350.      BEGIN
  1351.      GetDir(0,Dir.Path);
  1352.      FindFiles(Dir,Dir.Path);
  1353.      SortFiles(Dir);
  1354.      Dir.ArcType := fDIR;
  1355.      END;
  1356.  
  1357. END;
  1358.  
  1359. END.